{-
	Copyright (c) 2009 Aitor Lopez Fadrique <mailto:aitorlf@gmail.com>
	All rights reserved
	Licensed under GNU LGPL v2.1

	$Id: Deck.hs 15 2009-09-28 21:16:23Z aitorlf $

	This program is free software; you can redistribute it and/or
	modify it under the terms of the GNU Lesser General Public
	License version 2.1 (and just under that one) as published by
	the Free Software Foundation.

	This program is distributed in the hope that it will be useful,
	but without any warranty; without even the implied warranty of
	merchantability or fitness for a particular purpose. See the GNU
	Lesser General Public License for more details.

	You should have received a copy of the GNU Lesser General Public
	License along with this program; if not, write to the Free
	Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
	MA 02111-1307, USA.
-}

{-|
	Module		: Games.Cards.Deck
	Copyright	: (c) Aitor Lopez Fadrique <mailto:aitorlf@gmail.com>
	License		: GNU LGPL v2.1 <http://www.gnu.org/licenses/old-licenses/lgpl-2.1.html>

	Maintainer	: Aitor Lopez Fadrique <mailto:aitorlf@gmail.com>
	Stability	: provisional
	Portability	: portable

	Basic utilities and definitions to deal with Card games.

	This module defines the basis to program Card games. This involves the defintion
	of the type /Card/, as wels as the related /Suit/, /Rank/ and /Wild Card/, which are
	implemented as type-classes.
	This allows the easy definition of new Suits, Ranks or special wild cards and the
	direct creation of new card types (so decks).
	Due to restrictions in Haskell98 typing, cards are hard-typed and are not a type-class,
	as should be ideal to deal with new definitions.
-}
module Games.Cards.Deck(
		-- * Class-types to represent card attributes
		-- ** The rank of a card
		CardRank,
		-- ** The suit of a card
		CardSuit,
		-- ** Special treatment for wild cards
		WildCard(..),
		-- *** Utility functions to deal with wild cards (show and read the wildcard word
		-- "Joker" or whatever other fixed-string that may be needed)
		showsPrecWildcardString,
		readsPrecWildcardString,
		jokerString,
		-- *** Useful wild card instances (to default decks with none, one or two wild cards)
		WildCardNone(..),
		SingleJoker(..),
		DoubleJoker(..),
		-- * First-level elements in the module
		-- ** Card
		Card(..),
		-- *** Utilities to deal with cards
		isWildcard,
		-- ** Deck
		Deck,
		-- *** Utilities to deal with decks
		noWildcardSubDeck,
		onlyWillcardSubDeck,
		deck,
		multipleDecks,
		-- * French deck is considered the main type of deck and is used as
		-- an example on how to create new Cards and Decks
		-- ** Types defining cards and decks for the French deck
		FrenchRank(..),
		FrenchSuit(..),
		FrenchCard,
		FrenchDeck,
		FrenchJokerCard,
		FrenchJokerDeck,
		-- ** Instances of French decks
		frenchDeck,
		frenchJokerDeck,
	)where

import Data.List(elemIndex)


-- | This class represents every type that can be used as /Suit/ in a /Card/.
-- Each different suit will be treated by each different game program. That's
-- the reason why this class definition does not have any "member" function: we
-- can't make at this time any assumption aboud how cardgames will be.
class (Eq s, Enum s, Bounded s, Show s, Read s) => CardSuit s


-- | This class represents every type that can be used as /Rank/ in a /Card/.
-- All the comments about @'CardSuit'@ are equaly valid for this class.
class (Eq r, Ord r, Enum r, Bounded r, Show r, Read r) => CardRank r


-- | This class represents every type that can be used as /Wild Card/ in a /Card/
-- @'WildCard'@s are neither @'Enum'@ or @'Bounded'@. Each different definition will have
-- to decide if it is or not. This can have implications on the reuse of the same
-- @'WildCard'@ instance to represent different cards (for instance, the same
-- non-distinguishable Joker can appear twice within a given @'Deck'@).
-- A class-level function will be used to circumvent this problem.
class (Eq w, Show w, Read w) => WildCard w where
	-- | Returns the full set of available values to be used.
	-- Whether repeated, whether uniques, this is the only way in which the @'Deck'@ can
	-- locate the set of @'WildCard'@s.
	-- The default implementation returns an empty list of values.
	wildcardSet :: [w]
	wildcardSet = []

-- | Utility to show (in the @'Show'@ sense) a generic string. It is useful to be used as
-- a template for @'showsPrec'@ when declaring instances of @'WildCard'@ that are potentially
-- shown/read in a different way than the (usually single) constructor looks-like.
showsPrecWildcardString :: String -> Int -> w -> ShowS
showsPrecWildcardString v _ _ = (v ++)

-- | Utility to read (in the @'Read'@ sense) a generic value. It is useful to be used as
-- a template for @'readsPrec'@ when declaring instances of @'WildCard'@ that are potentially
-- shown/read in a different way than the (usually single) constructor looks-like.
readsPrecWildcardString :: w -> String -> Int -> ReadS w
readsPrecWildcardString w v _ = \s -> [(w, v') | (v, v') <- lex s]

-- | String representation of @"Joker"@, to be used in former render and parser functions.
jokerString :: String
jokerString = "Joker"

-- | Trivial @'WildCard'@ which effectively does not have any element.
data WildCardNone =
		-- | Trivial non-accessible constructor.
		WildCardNone
	deriving(Eq, Show, Read)
-- @'WildCardNone'@ is usable as a @'WildCard'@. (It does use the default definition
-- from the @'WildCard'@class to return an empty list of available values.)
instance WildCard WildCardNone

-- | Trivial @'WildCard'@ (/Joker/) which has one single element.
data SingleJoker =
		-- | Trivial non-accessible constructor.
		SingleJoker
	deriving(Eq)
-- Trivial show using utility...
instance Show SingleJoker where
	showsPrec = showsPrecWildcardString jokerString
-- Trivial read using utility...
instance Read SingleJoker where
	readsPrec = readsPrecWildcardString SingleJoker jokerString
-- @'SingleJoker'@ is usable as a @'WildCard'@.
-- As its own name states, has one single element.
instance WildCard SingleJoker where
	wildcardSet = replicate 1 SingleJoker

-- | Trivial @'WildCard'@ (/Joker/) consists on two (2) equal elements.
data DoubleJoker = DoubleJoker
	deriving(Eq)
-- Trivial instanciation to be available as @'WildCard'@, returning the only element twice.
instance WildCard DoubleJoker where
	wildcardSet = replicate 2 DoubleJoker
-- Trivial show using utility...
instance Show DoubleJoker where
	showsPrec = showsPrecWildcardString jokerString
-- Trivial read using utility...
instance Read DoubleJoker where
	readsPrec = readsPrecWildcardString DoubleJoker jokerString


-- | A @'Card'@ can consist on a pair of @('CardSuit', 'CardRank')@ or in a single @'WildCard'@.
-- The type is parametrized on the values for @'CardSuit'@, @'CardRank'@ and @'WildCard'@ via
-- type polymorphism.
-- Thought this definition is pretty straightforward and usable, it is nevertheless a quite tedious
-- job to create types for every possible suit or rank. Notice that it is still the best approach. Some
-- kind of universal implementation would become over-engineered and unusuable, as games are usually
-- highly dependant on the definitions of cards (suits, ranks and even jokers). If needed, it is
-- preferible to create class-types as the main interface for the game and let the different
-- card/decks (maybe created ad-hoc for the game) to implement them in the required way.
data (CardRank r, CardSuit s, WildCard w) => Card r s w =
		-- | Standard card. Pair of @'CardRank'@ and @'CardSuit'@.
		Card {
			-- | The rank of the card.
			rank :: r,
			-- | The suit of the card.
			suit :: s
		}
		-- | Wild Card. Single @'WildCard'@.
		| WildCard {
			-- | The wild-card token.
			wildcard :: w
		}
	deriving(Eq)

-- | @'Card'@s have rank-based order.
-- No order is defined between suits or wild cards. Users will have to deal with the
-- treatment of special orders (some games re-define the value of the cards)and wild cards.
instance (CardSuit s, CardRank r, WildCard w) => Ord (Card r s w) where
	compare (Card rank1 _) (Card rank2 _) = compare rank1 rank2
	compare _ _ = EQ

-- | @'Card'@s are enumerable.
-- The enumeration is based on the @'Deck'@ defined for every instance of @'Card'@.
instance (CardSuit s, CardRank r, WildCard w) => Enum (Card r s w) where
	toEnum = (deck !!)
	fromEnum card =
		let
			(Just i) = elemIndex card deck
		in i

-- | @'Card'@s are bounded.
-- The limits are those ones corresponding to the beginning and end of the standard deck.
instance (CardSuit s, CardRank r, WildCard w) => Bounded (Card r s w) where
	minBound = head deck
	maxBound = last deck

-- | Let us show our @'Card'@s. ;-)
instance (CardSuit s, CardRank r, WildCard w) => Show (Card r s w) where
	showsPrec p (Card rank suit) = ('<' :) . (showsPrec p rank) . (' ' :) . (showsPrec p suit) . ('>' :)
	showsPrec p (WildCard wildcard) = ('<' :) . (showsPrec p wildcard) . ('>' :)

-- | So read them. :-P
instance (CardSuit s, CardRank r, WildCard w) => Read (Card r s w) where
	readsPrec _ =
		([readCard, readWildCard] >>=) . (flip ($))
		where
			readCard, readWildCard :: (CardRank r, CardSuit s, WildCard w) => ReadS (Card r s w)
			readCard s =
				[(Card rank suit, t) |
					("<", r) <- lex s,
					(rank, r') <- reads r,
					(suit, s') <- reads r',
					(">", t) <- lex s']
			readWildCard s =
				[(WildCard wildcard, t) |
					("<", w) <- lex s,
					(wildcard, w') <- reads w,
					(">", t) <- lex w']

-- | Utility to check id a @'Card'@ is a wild card or is not.
isWildcard :: (CardRank r, CardSuit s, WildCard w) => Card r s w -> Bool
isWildcard (WildCard _) = True
isWildcard _ = False


-- | A @'Deck'@ is a list of @'Card'@s.
-- Is implemented as a list of @'Card'@s with the same type parametrization.
-- It is important to outline that @'Deck'@s are not instances of @'Eq'@, @'Enum'@, @'Bounded'@,
-- not @'Ord'@. Each use (dealing order, number of players, combinatoric combinations in
-- general) does determine the meaning of the hash, the game and so, the possible different
-- available @'Deck'@s.
-- In addition, @'WildCard'@s are not easily enumerable or boundable, which has to be taken
-- into account by each use (read /game/).
type Deck r s w =
		-- | Trivial definition to create @'Deck'@s: list of @'Card'@s
		[Card r s w]

-- | Some basic functions to automatically create (sub)decks from the properties of the specified
-- @'CardRank'@, @'CardSuit'@ and @'WildCard'@ types.

-- | Standard autogenerated sub-deck without wild cards.
noWildcardSubDeck :: (CardRank r, CardSuit s, WildCard w) => Deck r s w
noWildcardSubDeck = [Card rank suit | rank <- [minBound .. maxBound], suit <- [minBound .. maxBound]]

-- | Standard autogenerated (via @'WildCard.wildcardSet'@) sub-deck just consist on @'WildCard'@s.
onlyWillcardSubDeck :: (CardRank r, CardSuit s, WildCard w) => Deck r s w
onlyWillcardSubDeck = [WildCard wildcard | wildcard <- wildcardSet]

-- | Standard autogenerated (via @'noWildcardSubDeck'@ and @'onlyWillcardSubDeck'@) full deck for the given types.
deck :: (CardRank r, CardSuit s, WildCard w) => Deck r s w
deck = noWildcardSubDeck ++ onlyWillcardSubDeck

-- | Utility to use multiple instances of a deck as a single pack.
multipleDecks :: (CardRank r, CardSuit s, WildCard w) => Int -> Deck r s w
multipleDecks n = concat $ replicate n deck


-- | Basic definitions to create a standard 52 cards French deck (@'FrenchDeck'@) and a not-so-standard
-- 54 cards (two wild cards) French deck (@'FrenchJokerDeck'@).
-- These definitions are to be used as models when creating new @'CardRank'@, @'CardSuit'@, @'WildCard'@,
-- @'Card'@ and @'Deck'@ instances.

-- | Well-known ranks for the French deck.
data FrenchRank =
		-- | 'Two' (/2/)
		Two
		-- | 'Three' (/3/)
		| Three
		-- | 'Four' (/4/)
		| Four
		-- | 'Five' (/5/)
		| Five
		-- | 'Six' (/6/)
		| Six
		-- | 'Seven' (/7/)
		| Seven
		-- | 'Eight' (/8/)
		| Eight
		-- | 'Nine' (/9/)
		| Nine
		-- | 'Ten' (/10/)
		| Ten
		-- | 'Jack' (/J/)
		| Jack
		-- | 'Queen' (/Q/)
		| Queen
		-- | 'King' (/K/)
		| King
		-- | 'Ace' (/A/)
		| Ace
	deriving (Eq, Ord, Enum, Bounded, Show, Read)
-- Trivial instanciation to be available as @'CardRank'@.
instance CardRank FrenchRank


-- | Well-known suits for the French deck.
data FrenchSuit =
		-- | 'Diamonds' (/&diams;/)
		Diamonds
		-- | 'Spades' (/&spades;/)
		| Spades
		-- | 'Hearts' (/&spades;/)
		| Hearts
		-- | 'Clubs' (/&clubs;/)
		| Clubs
	deriving (Eq, Enum, Bounded, Show, Read)
-- Trivial instanciation to be available as @'CardSuit'@.
instance CardSuit FrenchSuit


-- | Definition of the standard French @'Card'@s and @'Deck'@s, with and without @'WildCard'@s
-- (@'Joker'@, consisting on two equal elements).

-- | 52 cards French deck, with no wild cards.
-- | French card type.
type FrenchCard = Card FrenchRank FrenchSuit WildCardNone

-- | French deck type.
type FrenchDeck = Deck FrenchRank FrenchSuit WildCardNone

-- | French deck instance.
frenchDeck :: FrenchDeck
frenchDeck = deck

-- | 54 cards French deck, with two equal wild cards.
-- | French (with wildcard) card.
type FrenchJokerCard = Card FrenchRank FrenchSuit DoubleJoker

-- | French (with wildcard) deck.
type FrenchJokerDeck = Deck FrenchRank FrenchSuit DoubleJoker

-- | French (with wildcard) deck instance.
frenchJokerDeck :: FrenchJokerDeck
frenchJokerDeck = deck
